C ----------------------------------------------------------------------
C
C       H I N I T   -   Heap Initialise
C
C       Heap Format: Array(1) contains the address of the first element
C                       on the free list.
C                    Array(2) contains the highest element used so far
C                       (i.e. with *any* information written in).
C

        SUBROUTINE HINIT(ARRAY,ASIZE)
        INTEGER ASIZE,ARRAY(ASIZE)

        EXTERNAL ERROR

        IF (ASIZE.LT.3) CALL ERROR('HINIT: ARRAY TOO SMALL')
        ARRAY(1)=3
        ARRAY(2)=4
        ARRAY(3)=ASIZE-2
        ARRAY(4)=0

        END
C ----------------------------------------------------------------------
C
C       H A L L O C   -   Heap: Allocate storage block
C
C       Storage block format:
C           Array(HALLOC-1)=size of this block
C           Array(HALLOC...HALLOC+BSIZE-1)=the block itself
C
C       Free-list block format:
C           Array(FPTR)=size of this block
C           Array(FPTR+1)=address of next block or zero
C

        INTEGER FUNCTION HALLOC(ARRAY,BSIZE)
        INTEGER ARRAY(*),BSIZE

        INTEGER FPTR,LAST

        FPTR=ARRAY(1)
        LAST=1
        IF (FPTR.EQ.0) CALL ERROR('HALLOC: FREE LIST EXHAUSTED')
 100    IF (ARRAY(FPTR).GT.BSIZE) THEN
C We found a free-list element big enough for this block
            HALLOC=FPTR+1
            IF (ARRAY(FPTR).LE.BSIZE+2) THEN
C If exactly same size or one bigger ...
C ... unlink this block from the freelist
                ARRAY(LAST)=ARRAY(FPTR+1)
C ... update the "heaptop" variable
                ARRAY(2)=MAX(ARRAY(2),HALLOC+ARRAY(FPTR))
            ELSE
C No - Must split the freelist block into two, allocating the
C lower part to the user ...
C ... Make link to the free-list block we are about to create
                ARRAY(LAST)=FPTR+BSIZE+1
C ... Make the new free-list block
                ARRAY(FPTR+BSIZE+1)=ARRAY(FPTR)-BSIZE-1
                ARRAY(FPTR+BSIZE+2)=ARRAY(FPTR+1)
C ... Split off the storage block to return to the user
                ARRAY(FPTR)=BSIZE+1
C ... Update the "heaptop" variable
                ARRAY(2)=MAX(ARRAY(2),FPTR+BSIZE+2)
            END IF
        ELSE
C This free-list element not big enough for the user's request
            LAST=FPTR+1
            FPTR=ARRAY(LAST)
            IF (FPTR.NE.0) GOTO 100
            CALL ERROR('HALLOC: HEAP STORAGE EXHAUSTED/FRAGMENTED')
        END IF

        END
C ----------------------------------------------------------------------
C
C       H G E T 1   -   Heap: Get a single integer from storage
C
C       Note: This does not allocate a "size" entry, and so can never be
C             released using HFREE (it is assumed that if the user calls
C             this routine they know what they are doing).  This has the
C             advantage (for single-word entries) of no overhead.
C

        INTEGER FUNCTION HGET1(ARRAY)
        INTEGER ARRAY(*)

        EXTERNAL ERROR

        IF (ARRAY(1).EQ.0) CALL ERROR('HGET1: FREE LIST EXHAUSTED')

        HGET1=ARRAY(1)
        IF (ARRAY(ARRAY(1)).EQ.2) THEN
C This free-list entry is already at the minimum size, so we must use up
C the whole 2 elements and delete it.
            ARRAY(1)=ARRAY(ARRAY(1)+1)
        ELSE
C Steal a word from the front of this entry
            ARRAY(ARRAY(1)+2)=ARRAY(ARRAY(1)+1)
            ARRAY(ARRAY(1)+1)=ARRAY(ARRAY(1))-1
            ARRAY(1)=ARRAY(1)+1
            IF (ARRAY(2).LT.ARRAY(1)+1) ARRAY(2)=ARRAY(1)+1
        END IF

        END
C ----------------------------------------------------------------------
C
C       H F R E E   -   Heap: Free a storage block
C

        SUBROUTINE HFREE(ARRAY,ELT)
        INTEGER ARRAY(*),ELT

C This is simple - just create a new free-list block from the storage
C block and put it onto the front of the free-list; this makes the
C free-list function somewhat like a stack (but only somewhat).

        ARRAY(ELT)=ARRAY(1)
        ARRAY(1)=ELT-1

        END
